module FLC  where
import Data.List
-- import qualified Data.HashMap.Lazy as HMap
-- import qualified Data.Map.Lazy as Map
import qualified Data.IntMap.Lazy as IMap
import Control.Parallel.Strategies
import Control.Parallel
import Control.Exception

import Control.DeepSeq
import Data.List 





-- 余切向量描述了导数
-- 一般的 \partial f \partial t dt 是f诱导的余切向量

--

elem_index::(Eq a)=> a->[a]->[Int]
elem_index x xs =[  i |i<- [0..(length xs-1)] ,(xs!!i)==x] 



list_replace:: [a]->Int->[a]->[a]
list_replace [] _ _ =[]
list_replace l index re=
    if len2 > len1 || index <0 ||index >=len1 ||index + len2-1 >=len1 then
        l
    else 
        [if elem i [index..(index+len2-1)] then re !! (i-index) else l !!i |i<-[0..len1-1]]
    where 
        len1=length l
        len2=length re






data Fun_Linear_Composition l=Fundamental_fun{
    ff_get_id:: Int,
    ff_get_compose:: (Double,Double),
    ff_get_right_linear_facs:: [Double],
    --ff_get_fun_fac:: [Double],
    --ff_get_fun::(Double->Double),
    -- ff_get_right_linear_facs::[Double],
    --ff_convolution:: [Double],  
    ff_get_trait::Maybe l
}|Fun_Linear_Composition{
    flc_get_id::Int,
    flc_get_compose::(Double,Double ),
    flc_get_right_linear_facs:: [Double],
    flc_get_right_functions::[Int],     
    
    --flc_get_right_linear_facs::[Double],
    -- ff_convolution:: [Double],
    flc_get_trait:: Maybe l
}

---通过合并mesh的方法，解决网格模块化
data Functional_Mesh f l=Functional_Mesh{
    fm_get_functions:: IMap.IntMap (Fun_Linear_Composition l), 
    --fm_get_start_functions::[Int],
    fm_get_input_length:: Int,   
    fm_get_end_functions::[Int], 
    fm_get_id_name:: Int,
    fm_get_trait::Maybe f
}

instance Eq (Fun_Linear_Composition l) where
    Fun_Linear_Composition id1 _ _ _ _   == Fun_Linear_Composition id2 _ _ _ _   = (id1==id2)
    Fundamental_fun id1 _ _ _   ==Fundamental_fun id2 _ _ _   = (id1==id2)   
    Fun_Linear_Composition id1 _ _ _  _  == Fundamental_fun _ _ _ _   = False
    Fundamental_fun _ _ _ _   == Fun_Linear_Composition id1 _ _  _ _   = False
 

fun_get_id:: Fun_Linear_Composition l->Int
fun_get_id (Fundamental_fun id1 _ _  _ )=id1
fun_get_id (Fun_Linear_Composition id1 _ _ _ _ ) =id1 


fun_get_right_facs:: Fun_Linear_Composition l ->[Double]
fun_get_right_facs (Fundamental_fun _ _ facs _  )=facs
fun_get_right_facs (Fun_Linear_Composition _ _  facs _ _)= facs  


fun_get_right_funs :: Fun_Linear_Composition l ->Maybe  [Int]
fun_get_right_funs (Fundamental_fun _ _ _ _) = Nothing
fun_get_right_funs (Fun_Linear_Composition _ _ facs2 funs2 _ )  = Just  funs2



-- 根据线性组合函数和被线性组合函数的id, 获取线性组合的因子项


fun_get_right_fac::Fun_Linear_Composition l ->Int ->Maybe Double 
fun_get_right_fac (Fun_Linear_Composition _ _ facs2 funs2 _ ) id1=if list1 ==[]
    then Nothing
    else 
        Just $ facs2 !! (head list1)
    where 
        list1=elem_index id1 funs2 

fun_get_right_fac (Fundamental_fun _ _ facs _ ) id1 = Just $ facs!!id1








fm_empty::Functional_Mesh f l 
fm_empty= Functional_Mesh IMap.empty 0  [] 0  Nothing


fm_set_functions::IMap.IntMap (Fun_Linear_Composition l)-> Functional_Mesh f l ->Functional_Mesh f l 
fm_set_functions map1 (Functional_Mesh map2 i_len ef id_name t)=Functional_Mesh map1 i_len ef id_name t


fm_set_input_length:: Int-> Functional_Mesh f l -> Functional_Mesh f l 
fm_set_input_length  i_len1  (Functional_Mesh map1 i_len ef id_name t)= Functional_Mesh map1 i_len1 ef id_name t 

-- fm_set_start_points::[Double] -> Functional_Mesh f l->Functional_Mesh f l 
-- fm_set_start_points p (Functional_Mesh map1 p1 ef id_name t)=Functional_Mesh map1 p ef id_name t


fm_set_end_functions::[Int]->Functional_Mesh f l ->Functional_Mesh f l 
fm_set_end_functions ef (Functional_Mesh map1 i_len ef1 id_name t)=Functional_Mesh map1 i_len ef id_name t 

fm_set_id_name :: Int -> Functional_Mesh f l ->Functional_Mesh f l 
fm_set_id_name id1 (Functional_Mesh funs i_len ef id2 t)= (Functional_Mesh funs i_len ef id1 t)

fm_get_fun::Functional_Mesh f l ->Int ->Maybe (Fun_Linear_Composition l)
fm_get_fun m id1= IMap.lookup id1 $ fm_get_functions m  

fm_insert_fun::Fun_Linear_Composition l-> Functional_Mesh f l->Functional_Mesh f l 
fm_insert_fun  fun m = fm_set_functions  nfuns m 
    where 
        funs= fm_get_functions m 
        nfuns= IMap.insert (fun_get_id fun) fun funs 



fm_get_right_fac::Functional_Mesh f l ->Int ->Int ->Maybe Double
fm_get_right_fac m id1 id2= if fun1==Nothing
    then Nothing
    else 
        fun_get_right_fac ((\(Just x)->x)  fun1) id2
    where 
        fun1=fm_get_fun m id1
      


--alter_flc 




myalpha:: ([Double]->Double)->([Double]->Double)
myalpha f= \x-> max (f x) 0

mybeta:: ([Double]->Double)->([Double]->Double)
mybeta f= myadd  f  (mymult (-1) (myalpha f))

myadd::([Double]->Double)->([Double]->Double)->([Double]->Double)
myadd f1 f2= (\x->f1 x + f2 x)


mymult::Double->([Double]->Double)->([Double]->Double)
mymult fac f1 = (*) fac.f1

-- 新的核心处理函数
-- f=f_1 - f_2
-- cut(f)=a*f_1+ b*f_2


-- mys1::[Double] ->Double
-- mys1 x= (x!! 0) 


fm_create_rightfac::Int->Int->Double->Functional_Mesh f l-> Maybe (Functional_Mesh f l)
fm_create_rightfac id1 id2 fac m=if fun1==Nothing || fun2==Nothing 
    then
        Nothing 
    else 
        myfun ((\(Just x)->x)  fun1) ( (\(Just x)->x) fun2) m
    where 
        fun1=fm_get_fun m id1
        fun2=fm_get_fun m id2
        myfun::Fun_Linear_Composition l-> Fun_Linear_Composition l -> Functional_Mesh f l->Maybe (Functional_Mesh f l) 
        myfun (Fundamental_fun _ _  _ _ )  _ _ = Nothing  

        myfun (Fun_Linear_Composition _ com1 facs1 funs1  t1 )  _ m1= if indexs==[]
            then 
                Just $ (fm_insert_fun (Fun_Linear_Composition id2 com1 (fac:facs1) (id1:funs1)  t1 ) m1)  
            else 
                Nothing
            where 
                indexs= (elem_index id2 funs1)
        


-- alter_ff

--from right to left
-- id1 is right
-- id2 is left 


fm_alter_rightfac::Int->Int->Double->Functional_Mesh f l ->Maybe (Functional_Mesh f l )
fm_alter_rightfac id1 id2 fac m = if fun1 == Nothing 
    then 
        Nothing
    else  
        if fun_get_right_fac ((\(Just x)->x) fun1) id2 ==Nothing 
        then 
            Nothing
        else 
            Just $ fm_insert_fun  (myfun ((\(Just x)->x) fun1))  m 
    where 
        fun1 = fm_get_fun m id1
        myfun:: Fun_Linear_Composition l->Fun_Linear_Composition l
        myfun (Fundamental_fun id3 com3 facs3 t3 )= (Fundamental_fun id3 com3 (list_replace facs3 id2  [fac]  ) t3 ) 
        myfun (Fun_Linear_Composition id3 com3 facs3 funs3  t3)= (Fun_Linear_Composition id3 com3 (list_replace facs3 (head $ elem_index id2 funs3) [fac]  ) funs3 t3)        

         

-- fm_alter_ff_rightfacs::Int->Int->Double


insert_flc2mesh:: (Double,Double)->[Double]->[Int]-> Functional_Mesh f l ->Functional_Mesh f l 
insert_flc2mesh com facs funs m=fm_insert_fun nfun $ fm_set_id_name (id1+1) m  
    where 
        id1=fm_get_id_name m 
        nfun = Fun_Linear_Composition id1 com facs funs Nothing



-- (alpha,beta) facs fun 
-- 
-- generally, beta=1- alpha

insert_ff2mesh:: (Double,Double)->[Double] ->Functional_Mesh f l -> Functional_Mesh f l
insert_ff2mesh com facs m =fm_insert_fun nfun $ fm_set_id_name (id1+1) m  
    where 
        id1=fm_get_id_name m 
        nfun= Fundamental_fun id1 com facs Nothing
        



-- 
-- 根据id获取函数(线性组合和非线性处理后的函数)
---

get_real_fun_from_mesh::Functional_Mesh f l->Int ->Maybe ([Double]->Double)
get_real_fun_from_mesh  m id1= if com_fun==Nothing 
    then Nothing 
    else 
        Just (myfun $ (\(Just x)->x) com_fun)
    where 
        com_fun=fm_get_fun m id1 

        myfun1:: [Double]->([Double]->Double)
        myfun1  l = \x-> ( (sum $ zipWith (*) x (init l))+ last l)   

        myfun::Fun_Linear_Composition l -> ([Double]->Double)
        myfun (Fundamental_fun id1 com facs _ )= 
            myadd (mymult (fst com) (myalpha (myfun1 facs)  )) (mymult (snd com) (mybeta (myfun1 facs)  ))  
        myfun (Fun_Linear_Composition id1 com facs funs  _  )= 
            myadd (mymult (fst com) (myalpha nfun)) (mymult (snd com) (mybeta nfun))       
            where 
                --myfun2=(\x y->get_left_fun_from_mesh y x) 
                nfun=foldl' myadd  (\x->last facs)  $ zipWith (\x y->(*) x.y)  (init facs) $ map ( (\(Just x)->x).get_real_fun_from_mesh m) funs 





-- -- 



-- fm_get_end_behavior:: Functional_Mesh f l ->([Double]->Double)
-- fm_get_end_behavior m= map (\x->((\(Just y)->y) (get_left_fun_from_mesh m x)) start_points) end_functions
--     where
--         end_functions = fm_get_end_functions m




-- 微分项

-- get_all_paths_pass_to_x::Functional_Mesh f l->Int->IMap.IntMap (IMap.IntMap Int)
-- get_all_paths_pass_to_x m id1=myfun m id1 (IMap.empty) 
--     where 
--         myfun::Functional_Mesh f l-> Int->IMap.IntMap (IMap.IntMap Int)->IMap.IntMap (IMap.IntMap Int)
--         myfun m1 id2 map1= foldl' (\x y-> myfun m1 y x) nmap1 left_funcs_id 
--             where
--                 value_map=IMap.insert id2 0 (IMap.empty)
--                 fun = fm_get_fun m1 id2
--                 left_funcs_id=fun_get_left_functions ((\(Just x)->x) fun )
--                 nmap1=foldl'  (\x y->IMap.insert y value_map x ) map1 left_funcs_id




-- 逻辑斯蒂映射
logistic_map::Double->Double
logistic_map x= 3.9819*x*(1-x)


logistic_map_list :: Int ->Double->[Double]
logistic_map_list n y= my_fun (n-1) [FLC.logistic_map y]
  where 
    my_fun:: Int->[Double]->[Double]
    my_fun 0 x= x
    my_fun nn x= my_fun (nn-1) ( (FLC.logistic_map (head x)  ):x )

tent_map::Double->Double
tent_map x 
    | x <= 0.5 = x*u
    | otherwise = (1-x)*u
    
    where 
        u=1.941

logistic_tent_map::Double->Double
logistic_tent_map x= (logistic_map.tent_map) x 



-- get_all_paths_differential::Functional_Mesh f l -> IMap.IntMap (IMap.IntMap Int)
-- get_all_paths_differential



--         myfun1::
--         myfun1:: 

-- -- get_one_single_path_differential::Functional_Mesh f l ->


flc_variation::Double->  Fun_Linear_Composition l->Fun_Linear_Composition l
flc_variation random (Fundamental_fun id1 (coms11,coms12) rfacs t) =  Fundamental_fun id1 (coms11+r_list !! 0  ,coms12+ r_list !! 1) r_list1 t 
    where 
        len= length rfacs 
        r_list=map (\x-> (x-0.5)*0.8 ) $ logistic_map_list (len+2) random 
        r_list1=zipWith (+)  (drop 2 r_list ) rfacs   
flc_variation random (Fun_Linear_Composition id1 (coms11,coms12) rfacs funs t) =  Fun_Linear_Composition id1 (coms11+r_list !! 0  ,coms12+ r_list !! 1) r_list1 funs t 
    where 
        len= length rfacs 
        r_list=map (\x-> (x-0.5)*0.8 ) $ logistic_map_list (len+2) random 
        r_list1=zipWith (+)  (drop 2 r_list ) rfacs   










-- 繁殖算子
-- 随机生长一批，随机连线一批
-- 

-- insert_ff2mesh:: (Double,Double)->[Double] ->Functional_Mesh f l -> Functional_Mesh f l
-- insert_flc2mesh:: (Double,Double)->[Double]->[Int]-> Functional_Mesh f l ->Functional_Mesh f l 

myNub :: (Eq a) => [a] -> [a]
myNub (x:xs) = x : myNub (filter (/= x) xs)
myNub [] = []

-- nub:: Eq a=> [a]->[a]
-- nub [] = []
-- nub (x:xs)
--     | x `elem` xs = nub xs
--     | otherwise = x : nub xs




spread_once:: Functional_Mesh f l-> [Int]->[Int]
spread_once m o_list= foldl  myfun1  []  o_list
    where 
        myfun:: [Int]->[Int]->[Int]
        myfun l1 [] =l1
        myfun l1 (x:xs)=if elem x l1 
            then 
                myfun l1 xs
            else 
                myfun (x:l1) xs 
        
        myfun1:: [Int]->Int->[Int]
        myfun1 l1 id1= if temp_fun  ==Nothing || fun_get_right_funs ((\(Just x)->x)  temp_fun) ==Nothing
            then 
                l1 
            else  
                myfun l1 $ (\(Just x)->x)  (fun_get_right_funs ((\(Just x)->x)  temp_fun)) 
            where 
                temp_fun=fm_get_fun m id1



-- fm_get_fun

breed_operator::Double-> Functional_Mesh f l -> Functional_Mesh f l 
breed_operator random (Functional_Mesh map2 i_len ef id_name t) = Functional_Mesh (IMap.fromList re_funs_list) i_len  ef id_name t 
    where  
        my_par_zipwith:: [Double]-> [(Int,Fun_Linear_Composition l)]->Eval [(Int,Fun_Linear_Composition l)]
        my_par_zipwith [] _ = return []
        my_par_zipwith _ [] = return []
        my_par_zipwith (r:rs) ( kv:kvs )= do 
            re_p<-rpar  (fst kv, flc_variation r (snd kv))
            re_s<-my_par_zipwith rs kvs
            return (re_p: re_s)

        funs_list=IMap.toList map2
        len= length funs_list
        random_list= logistic_map_list len random
        re_funs_list= runEval $ my_par_zipwith random_list funs_list

     
        -- create_new_flc::Double-> Functional_Mesh f l-> Functional_Mesh f l
        -- create_new_flc random1 m= if (abs random1) < 0.5 
        --     then 
        --         insert_ff2mesh (random_list_s!! 0,random_list_s!!1 ) (drop 2 random_list_s ) m
        --     else 
        --         m
        --     where 
        --         random_list_s= map (\x-> x-0.5) $ logistic_map_list (i_len+2) random1
                 
-- 物竟天则算子
--

fib:: Int->Int 
fib 0 =1
fib 1 =1 
fib n= fib (n-1) +fib (n-2)


test1 = do
  --x <- rpar (fib 44)
  y <- rpar (fib 45)
  return y

someFunc :: IO ()
someFunc = do --print $ resultPar
    -- r<- evaluate (runEval test1)
    -- print r
    print$ runEval $ (do
        --fib44<- rpar (force $fib 44) 
        fib45<- rpar (fib 45)
        fib46<- rpar (fib 46)
        fib47<- rpar ( fib 47)
        -- rseq fib44

        -- rseq fib45
        -- rseq fib46
        rseq fib47
        return [fib45,fib46,fib47]
        ) 

    where
        resultPlain=[fib 44,fib 45,fib 46 ,fib 47]
        resultPar= parMap rpar (fib)  [ 44, 45, 46 , 47]
        resultSeq= parMap rseq (fib)  [ 44, 45, 46 , 47]


 
-- someFunc :: IO ()
-- someFunc = do
--     putStrLn $show $   (\(Just x)->x) (get_real_fun_from_mesh m2 0) $ [-1.1]
--     putStrLn "someFunc"
--     where 
--         --n1=Fundamental_fun 0 (0.4,0.6) [1,0] id []  Nothing

--         m=fm_empty
--         -- (alpha ,beta) facs fun  
--         m1=insert_ff2mesh (0.4,0.6) (\x-> head x *0.4+0.2  ) m
--         m2=(\(Just x)->x) m1 
--         -- m1=fm_set_functions ( IMap.insert 0 n1 $ fm_get_functions m) m

